home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH3 / SRC / TOGRAY.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1996-01-24  |  6.2 KB  |  191 lines
  1. VERSION 4.00
  2. Begin VB.Form ToGrayForm 
  3.    Caption         =   "PalEdit"
  4.    ClientHeight    =   2550
  5.    ClientLeft      =   2595
  6.    ClientTop       =   2265
  7.    ClientWidth     =   3150
  8.    Height          =   2955
  9.    Left            =   2535
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   170.439
  12.    ScaleMode       =   0  'User
  13.    ScaleWidth      =   210
  14.    Top             =   1920
  15.    Visible         =   0   'False
  16.    Width           =   3270
  17.    Begin VB.PictureBox ImagePict 
  18.       AutoRedraw      =   -1  'True
  19.       Height          =   2535
  20.       Left            =   0
  21.       Picture         =   "ToGray.frx":0000
  22.       ScaleHeight     =   165
  23.       ScaleMode       =   3  'Pixel
  24.       ScaleWidth      =   205
  25.       TabIndex        =   0
  26.       Top             =   0
  27.       Width           =   3135
  28.    End
  29. Attribute VB_Name = "ToGrayForm"
  30. Attribute VB_Creatable = False
  31. Attribute VB_Exposed = False
  32. Option Explicit
  33. Const SysPalSize = 256
  34. Const StaticColor1 = 9
  35. Const StaticColor2 = 246
  36. Dim LogicalPalette As Integer
  37. ' ***********************************************
  38. ' Load the ImagePict palette so its entries
  39. ' match the system entries.
  40. ' ***********************************************
  41. Sub LoadLogicalPalette()
  42. Dim palentry(0 To 255) As PALETTEENTRY
  43. Dim blanked(0 To 255) As PALETTEENTRY
  44. Dim i As Integer
  45.     ' Save the logical pallette handle.
  46.     LogicalPalette = ImagePict.Picture.hPal
  47.     ' Make sure ImagePict has the foreground palette.
  48.     i = RealizePalette(ImagePict.hdc)
  49.     ' Give the system a chance to catch up.
  50.     DoEvents
  51.     ' Make the logical palette as big as possible.
  52.     If ResizePalette(LogicalPalette, SysPalSize) = 0 Then
  53.         Beep
  54.         MsgBox "Error resizing logical palette.", _
  55.             vbExclamation
  56.         Exit Sub
  57.     End If
  58.     ' Get the system palette entries.
  59.     i = GetSystemPaletteEntries(ImagePict.hdc, 0, SysPalSize, palentry(0))
  60.     ' Blank the non-static colors.
  61.     For i = 0 To StaticColor1
  62.         blanked(i) = palentry(i)
  63.     Next i
  64.     For i = StaticColor1 + 1 To StaticColor2 - 1
  65.         With blanked(i)
  66.             .peRed = 0
  67.             .peGreen = 0
  68.             .peBlue = 0
  69.             .peFlags = PC_NOCOLLAPSE
  70.         End With
  71.     Next i
  72.     For i = StaticColor2 To 255
  73.         blanked(i) = palentry(i)
  74.     Next i
  75.     i = SetPaletteEntries(LogicalPalette, 0, SysPalSize, blanked(0))
  76.     ' Insert the non-static colors.
  77.     For i = StaticColor1 + 1 To StaticColor2 - 1
  78.         palentry(i).peFlags = PC_NOCOLLAPSE
  79.     Next i
  80.     i = SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))
  81.     ' Realize the new palette values.
  82.     i = RealizePalette(ImagePict.hdc)
  83. End Sub
  84. ' ***********************************************
  85. ' Load the indicated file and prepare to work
  86. ' with its palette.
  87. ' ***********************************************
  88. Sub LoadImagePict(fname As String)
  89.     On Error GoTo LoadFileError
  90.     ImagePict.Picture = LoadPicture(fname)
  91.     Exit Sub
  92. LoadFileError:
  93.     Beep
  94.     MsgBox "Error loading file " & fname & "." & _
  95.         vbCrLf & Error$
  96.     Exit Sub
  97. End Sub
  98. ' ***********************************************
  99. ' 1. Make sure we can handle palettes.
  100. ' 2. Find out how big the system palette is and how
  101. ' many static colors there are.
  102. ' 3. Load and display the system palette.
  103. ' ***********************************************
  104. Private Sub Form_Load()
  105. Dim cmd As String
  106. Dim sp As Integer
  107. Dim infile As String
  108. Dim outfile As String
  109.     ' Make sure the screen supports palettes.
  110.     If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
  111.         Beep
  112.         MsgBox "This monitor does not support palettes.", _
  113.             vbCritical
  114.         End
  115.     End If
  116.     ' Get the input and output file names.
  117.     cmd = Trim$(Command)
  118.     If cmd = "" Then GoTo Usage
  119.     sp = InStr(cmd, " ")
  120.     If sp = 0 Then
  121.         infile = cmd
  122.     Else
  123.         infile = Left$(cmd, sp - 1)
  124.         If sp < Len(cmd) Then _
  125.             outfile = Trim$(Mid$(cmd, sp + 1))
  126.     End If
  127.     If outfile = "" Then outfile = infile
  128.         
  129.     ' RealizePalette doesn't work unless the
  130.     ' picture is visible.
  131.     Me.Show
  132.     ' Load image, convert, and save the image.
  133.     LoadImagePict infile
  134.     LoadLogicalPalette
  135.     ConvertToGrays
  136.     SaveImagePict outfile
  137.     End
  138. Usage:
  139.     Beep
  140.     MsgBox "Usage: ToGray infile [outfile]", vbCritical
  141.     End
  142. End Sub
  143. ' ***********************************************
  144. ' Save the picture in the indicated file.
  145. ' ***********************************************
  146. Sub SaveImagePict(fname As String)
  147.     On Error GoTo SaveError
  148.     SavePicture ImagePict.Picture, fname
  149.     Exit Sub
  150. SaveError:
  151.     Beep
  152.     MsgBox "Error saving picture in file " & _
  153.         fname & "." & vbCrLf & vbCrLf & _
  154.         Error$, , vbExclamation
  155.     Exit Sub
  156. End Sub
  157. ' ***********************************************
  158. ' Replace colors with appropriate grays.
  159. ' ***********************************************
  160. Private Sub ConvertToGrays()
  161. Dim palentry(0 To 255) As PALETTEENTRY
  162. Dim i As Integer
  163. Dim clr As Integer
  164.     ' Get the current color values.
  165.     i = GetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))
  166.     ' Fill in the nearest shades.
  167.     For i = StaticColor1 + 1 To StaticColor2 - 1
  168.         With palentry(i)
  169.             clr = (CInt(.peRed) + .peGreen + .peBlue) / 3
  170.             .peRed = clr
  171.             .peGreen = clr
  172.             .peBlue = clr
  173.             .peFlags = PC_NOCOLLAPSE
  174.         End With
  175.     Next i
  176.     If SetPaletteEntries(LogicalPalette, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1)) = 0 Then
  177.         Beep
  178.         MsgBox "Error resetting colors.", , vbExclamation
  179.         Exit Sub
  180.     End If
  181.     i = RealizePalette(ImagePict.hdc)
  182. End Sub
  183. ' ************************************************
  184. ' Make the image as big as possible.
  185. ' (This is really only useful during debugging
  186. ' since the form is normally not visible.)
  187. ' ************************************************
  188. Private Sub Form_Resize()
  189.     ImagePict.Move 0, 0, ScaleWidth, ScaleHeight
  190. End Sub
  191.